package Net::OpenID::Server::Standalone;

our $VERSION;

BEGIN {
    $VERSION = '0.1.1';
    $Net::OpenID::Server::Standalone::Default =
        'Net::OpenID::Server::Standalone';
}

=pod

=head1 NAME

Net::OpenID::Server::Standalone - personal standalone OpenID server
ready-to-use out-of-the-box

=head1 SYNOPSIS

id script use this:

  Net::OpenID::Server::Standalone::id;

setup script use this:

  Net::OpenID::Server::Standalone::setup;

Some kind of L<Net::OpenID::Server::Standalone::Config> is a must. For more
sophisticated use see L</USAGE> below.

=head1 DESCRIPTION

Nossa is dedicated for fast installation of your own OpenID 'Server' on a
CGI/L<FCGI::Spawn> - enabled hosting. There is a lot of tweaks for common
needs known as: your own identity source to be pluggable with Config.pm, your
own design for user setup pages, location of your CGI::Session storage, your
SRE information, redirect to your HTTPS server for setup, etc.

Typical layout follows:

  ./ --- application root, e. g. $HOME on your hosting.
    lib/Net/OpenID/Server/Standalone/
      Config.pm --- configuration of your OpenID server,
                    created from sample Config.pm
    www/ or public_html/
      index.html or whatever to be your XRD document like it is at
      http://peter.vereshagin.org.
    cgi/ or perl/ or cgi-bin/ or www/
      id.cgi    or id.pl    or id    --- id script
      setup.cgi or setup.pl or setup --- setup script

Of course those mentioned last three can be on the different servers as
different URLs. The workflow is as follows: id script checks user identity and
setup shows forms. Target of those forms is an id script, too.

You may use your own MyApp.pm and MyApp/Config.pm ( see below ).

=head1 PREREQUISITES

Net::OpenID::Server, Data::UUID, MIME::Base64, HTML::Entities, Digest::MD5,
CGI, CGI::Session.

=cut

use strict;
use warnings;

use Net::OpenID::Server;
use Data::UUID;
use MIME::Base64 qw/encode_base64/;
use HTML::Entities qw/encode_entities/;
use Digest::MD5 qw/md5_base64/;
use CGI;
use CGI::Session;
use Math::Random::Secure;

my $configPackage;

=pod

=head1 Variables and Subs


=over

=item * C<$htmlStyle>

hash reference for HTML code for your setup pages: the 'start' key holds a
value for start of the page, and the 'end' key holds a value for trhe end.

=cut

our $htmlStyle = { start => '<html>', end => '</html>', };

sub _obj_push_url_arg { shift; Net::OpenID::Server::_push_url_arg(@_) }

=pod

=item * hashFunction()

is a function that provides hash for your password storage. MD5 is the default.

=cut

sub hashFunction { shift; md5_base64(@_) }

=pod

=item * new()

Object constructor, starts session and so on.

=cut

sub new {
    my ( $session, $nonce, $htmlStyleAttr );
    my ( $pkg => $cgi ) = @_;
    no strict 'refs';
    $htmlStyleAttr = ${ *{ $pkg . '::' }->{ 'htmlStyle' } };
    use strict 'refs';
    $configPackage = $pkg . "::Config";
    Carp::croak(
        "No $configPackage! (please create it from Config.pm.sample): $@")
        unless eval("use $configPackage; 1;");
    $cgi //= CGI->new;
    $cgi->charset('utf-8');

    # Random variable to avoid caching in user's agent
    my $rnd = encode_base64( Data::UUID->new->create() );
    chomp $rnd;
    my $setupUrl = $configPackage->get('setupUrl');
    __PACKAGE__->_obj_push_url_arg( \$setupUrl, 'rnd' => $rnd, );

    # Setup session
    my $session_href = $configPackage->get('session');
    $session = _create_storage($session_href);

    # Setup nonce storage
    my $nonce_href = $configPackage->get('nonce');
    $nonce = _create_storage($nonce_href);

    bless {
        'rnd'       => $rnd,
        'setupUrl'  => $setupUrl,
        'nonceDb'   => $nonce,
        'cgi'       => $cgi,
        'session'   => $session,
        'htmlStyle' => $htmlStyleAttr,
    }, $pkg;
}

# Function
# Creates a storage based on CGI::Session
# Takes     :   hash as tha first argument for CGI:Session constructor
# Requires  :   'name', 'dsn', 'expire' keys to be defined on the arg hash
# Returns   :   CGI::Session object
sub _create_storage {
    my $href = shift;
    my ( $name, $dsn, $expire ) = map { $href->{ $_ } } qw/name dsn expire/;
    my $storage = CGI::Session->new( $dsn => undef );
    $storage->name($name);
    Carp::croak( "Session error: " . CGI::Session->errstr ) unless $storage;
    $storage->expire($expire);
    return $storage;
}

sub serverSecret {
    my ( $self, $t ) = @_;

    # Try to get from cache
    my $nonceDb = $self->{ 'nonceDb' };
    my $rv      = $nonceDb->get($t);
    unless ( defined $rv ) {

        # Not found in cache, generate and store
        $rv = join(
            "",
            map {
                ( '0' .. '9', 'a' .. 'z', 'A' .. 'Z' )
                    [ Math::Random::Secure::irand(62) ]
                } ( 1 .. 255 )
        );
        $rv->store( $t => $rv );
    }
    return $rv;
}

=pod

=item * id()

performs identification, should be pointed as an 'openid.delegate' URL in your
XRD document ( located on your OpenID URL ).

=cut

sub id {
    my $self = ( @_ ? shift : __PACKAGE__ )->new;
    my $requireSsl = $configPackage->get('requireSsl');
    unless ( $requireSsl and $self->isRedirectedToSsl() ) {
        my $setupUrl = $self->{ setupUrl };
        my $cgi      = $self->{ 'cgi' };
        my $nos      = Net::OpenID::Server->new(
            get_args      => $cgi,
            post_args     => $cgi,
            get_user      => sub { $self->getUser(@_) },
            is_identity   => \&isIdentity,
            is_trusted    => sub { $self->isTrusted(@_) },
            server_secret => sub { $self->serverSecret(@_) },
            setup_url     => $setupUrl,
            compat        => 1,
        );
        my ( $type, $data ) = $nos->handle_page();
        my $redirect = [ '200', $data, -type => $type, ];
        if ( $type eq 'redirect' ) {
            my $user = $nos->get_user()->();

            #my $url = $data;
            my $url = {
                identity     => $nos->args('openid.identity'),
                return_to    => $nos->args('openid.return_to'),
                assoc_handle => $nos->args('openid.assoc_handle'),
                trust_root   => $nos->args('openid.trust_root'),
            };
            my $sre = $configPackage->get( 'users', $user, 'sre', );
            if ( defined($sre) and 'HASH' eq ref $sre ) {
                $url->{ additional_fields } = $sre;
            }
            $url = $nos->signed_return_url(%$url);
            $redirect = [ '301 Identity Provided', $url, ];
        }
        elsif ( $type eq 'setup' ) {
            my $url = $setupUrl;
            __PACKAGE__->_obj_push_url_arg( \$url, %$data, );
            $redirect = [ '301 Setup Required', $url, ];
        }
        $self->redirect(@$redirect);
    }
}

=pod

=item * setup()

shows forms for login, logout and for trust the requesting URL. For use in the
'setup' script.

=cut

sub setup {
    my $self = ( @_ ? shift : __PACKAGE__ )->new;
    my $idSvrUrl = $configPackage->get('idSvrUrl');
    __PACKAGE__->_obj_push_url_arg( \$idSvrUrl, 'rnd' => $self->{ rnd }, );
    $self->{ idSvrUrl } = $idSvrUrl;
    my ( $cgi, $session ) = ( $self->{ 'cgi' }, $self->{ 'session' } );
    my $action = $cgi->param('action');
    print $session->header;
    if ( $session->param('login') ) {

        if ( defined($action) and $action eq 'logout' ) {
            $session->delete;
            $session->flush;
            $self->printLoginForm;
        }
        elsif ( defined( $cgi->param('trust_root') )
            and length $cgi->param('trust_root') )
        {
            my $trustRoot = $cgi->param('trust_root');
            $self->printTrustForm( encode_entities($trustRoot) );
        }
        else {
            $self->printLogoutForm;
        }
    }
    else {
        $self->printLoginForm;
    }
}

=pod

=item * redirect() and redirectMessage()

overrideable for your inherited package needs. Use to take HTTP status and URL
location as parameters.  redirectMessage returns the message for user.

=cut

sub redirect {

    # Rest of @_ is used here later for the header
    my ( $self, $status, $location, ) = ( shift, shift, shift );
    my $session = $self->{ 'session' };
    if ( substr( $status, 0, 3 ) eq '200' ) {
        print $session->header( -status => $status, @_ );
        print $location;
    }
    else {
        print $session->header(
            -status   => $status,
            -location => $location,
            @_
        );
        print $self->redirectMessage( $status, $location, );
    }
}

sub redirectMessage {
    my ( $self, $status => $location ) = @_;
    my $style = $self->{ 'htmlStyle' };
    return <<EOF;
$$style{ 'start' }<h1
>$status</h1
><p
>The document is moved <a href='$location'>here.</a
></p><hr
/>nossa &mdash; Net::OpenID::Server::Standalone.$$style{ 'end' }
EOF
}

sub isRedirectedToSsl {
    my $self = shift;
    my $cgi  = $self->{ 'cgi' };
    my $mode = $cgi->param('openid.mode');
    if (defined($mode)
        and (  ( $mode eq 'checkid_setup' )
            or ( $mode eq 'checkid_immediate' ) )
        and ( $ENV{ SERVER_PORT } != 443 )
        )
    {
        my $url = 'https://' . $ENV{ HTTP_HOST };
        $url .= $ENV{ REQUEST_URI };
        $self->redirect( "301 SSL please", $url, );
    }
}

sub getUser {
    my $self       = shift;
    my $authorized = 0;
    my ( $login, $pass ) = $self->getAuth;
    my $users   = $configPackage->get('users');
    my $session = $self->{ 'session' };
    if ( defined($login) and defined $users->{ $login } ) {
        my $user = $users->{ $login };
        if ( defined($pass)
            and ( $user->{ pass } eq $self->hashFunction($pass) ) )
        {
            $session->param( login => $login );
            $session->flush;
            $authorized = 1;
        }
    }
    elsif ( defined( $session->param("login") )
        and length $session->param("login") )
    {
        $login      = $session->param("login");
        $authorized = 1;
    }
    if ($authorized) {
        return $login;
    }
    else {
        $self->requireAuth();
    }
}

sub getAuth {
    my $self = shift;
    my $cgi  = $self->{ 'cgi' };
    my ( $login, $password ) =
        map { defined( $cgi->param($_) ) ? $cgi->param($_) : ''; }
        qw/login password/;
    if (    defined($login)
        and length($login)
        and defined($password)
        and length($password) )
    {
        return $login, $password;
    }
    else {
        return;
    }
}

sub requireAuth {
    my $self   = shift;
    my $cgi    = $self->{ 'cgi' };
    my $params = $cgi->Vars;

    # map{ delete( $params->{ $_ } ) if defined $params->{ $_ } } qw/login
    # password action setup_trust_root/;
    $params = {
        map { substr( $_, 7, length($_) - 7 ) => $cgi->param($_) }
            grep /^openid\./,
        $cgi->param
    };
    my $setupUrl = $configPackage->get('setupUrl');
    __PACKAGE__->_obj_push_url_arg( \$setupUrl, %$params );
    print $self->redirect( "301 Login please", $setupUrl, );
    return undef;
}

sub isIdentity {
    my ( $user, $url ) = @_;
    return unless defined $user;
    my $configUrl = $configPackage->get( 'users', $user, 'url' );
    return defined($configUrl) and $configUrl eq $url;
}

sub isTrusted {
    my ( $self, $user, $trustRoot, $isIdentity ) = @_;
    my $cgi            = $self->{ 'cgi' };
    my $trusted        = 0;
    my $setupTrustRoot = $cgi->param('setup_trust_root');
    if ( defined($user) and defined($isIdentity) and $isIdentity ) {
        if ( defined($setupTrustRoot) and $setupTrustRoot eq 'Yes' ) {
            $trusted = 1;
        }
        else {
            my $trustRootCref =
                $configPackage->get( 'users', $user, 'trust_root', );
            if ( defined($trustRootCref) and 'CODE' eq ref $trustRootCref ) {
                $trusted = $trustRootCref->($trustRoot);
            }
        }
        if ( defined($setupTrustRoot) and length $setupTrustRoot ) {
            unless ($trusted) {
                $self->redirect( "301 Not Trusted", $trustRoot, );
                exit;
            }
        }
    }
    return $trusted;
}

=pod

=item * cgiHiddens()

function that turns OpenID values for the default setup_map of the
Net::OpenID::Server into the hidden inputs for the form on the setup URL.

=cut

sub cgiHiddens {
    my $self       = shift;
    my $cgi        = $self->{ 'cgi' };
    my $cgi_htmled = {
        map {
            encode_entities( $_, '<>&"\'' ) =>
                encode_entities( $cgi->param($_), '<>&"\'' )
            } $cgi->param
    };
    $cgi_htmled->{ mode } = 'checkid_setup';
    $cgi_htmled = join "\n", map {
        my $val = $cgi_htmled->{ $_ };
        "<input type='hidden' name='openid.$_' value='$val' />";
    } keys %$cgi_htmled;
    return \$cgi_htmled;
}

=pod

=item * printLoginForm()

prints login form for setup script;

=cut

sub printLoginForm {
    my $self     = shift;
    my $idSvrUrl = $self->{ idSvrUrl };
    my $hiddens  = $self->cgiHiddens;
    my $style    = $self->{ 'htmlStyle' };
    print <<EOF;
$$style{ 'start' }<form action='$idSvrUrl' method='POST'
>$$hiddens<table width='0' cellspacing='0' cellpadding='0' border='0'>
<tr>
<td>Login: </td><td><input type='text' name='login' /></td>
</tr><tr>
<td>Pzzwd: </td><td><input type='password' name='password' /></td>
</tr>
<tr><td colspan='2' align='center'><input type='submit' name='button' value='Go' /></td></tr>
</table></form>$$style{ 'end' }
EOF
}

=pod

=item * printLoginForm()

prints 'trust this root' form for setup script;

=cut

sub printTrustForm {
    my $self            = shift;
    my $trustRootHtmled = shift;
    my $idSvrUrl        = $self->{ idSvrUrl };
    my $hiddens         = $self->cgiHiddens;
    my $style           = $self->{ 'htmlStyle' };
    print <<EOF;
$$style{ 'start' }<form action='$idSvrUrl' method='POST'
>$$hiddens<table width='0' cellspacing='0' cellpadding='0' border='0'>
<tr>
<tr><td colspan='2' align='center'>Trust this root?<br
/><b>$trustRootHtmled</b></td></tr>
<tr><td align='center'><input type='submit' name='setup_trust_root'
value='Yes' /></td><td align='center'><input type='submit'
name='setup_trust_root' value='No' /></td>
</tr>
</table></form>$$style{ 'end' }
1G1
EOF
}

=pod

=item * printLoginForm()

prints logout form for setup script;

=cut

sub printLogoutForm {
    my $self     = shift;
    my $setupUrl = $self->{ setupUrl };
    my $style    = $self->{ 'htmlStyle' };
    print <<EOF;
$$style{ 'start' }<form action='$setupUrl' method='POST'
><input type='hidden' name='action' value='logout'
/><input type='submit' name='button' value='Out'
/></form>$$style{ 'end' }
EOF
}

=pod

=back

=head1 USAGE

For 'do it quick' see the examples: index.html, id and setup. Also,
L<Net::OpenID::Server::Standalone::Config> is an example about how you could
set up your own ::Config. You should do it in any case.

For more custom-made setup you can inherit Nossa like this:

    $ cat lib/MyApp/Nossa.pm
    package MyApp::Nossa;

    use strict;
    use warnings;

    # inheritance stuff
    use base qw/Net::OpenID::Server::Standalone/;

    # your own hash function initialization
    use Digest::SHA256;
    my $dig = Digest::SHA256::new( 512 );

    # your own stylings around forms; override the print*Form methods for even
    # more and/or inner styling
    our $htmlStyle = { start  => "<html><body height='100%'><table width='100%'
                                      height='100%'"
                                ."><tr><td height='100%' align='center'
                                      valign='middle'"
                                .">",
                       end    => "</td></tr>"
                                ."</table></form></td></tr></table></body
                                      ></html>",
    };

    # the hash method
    sub hashFunction{ shift; my $pass = shift; $dig->hexhash($pass) }

    1;

    $ cat lib/MyApp/Nossa/Config.pm
    package MyApp::Nossa::Config;

    use strict;
    use warnings;

    use base qw/Net::OpenID::Server::Standalone::Config/;

    our $config = {
      # set up your values here as described in
      # L<Net::OpenID::Server::Standalone::Config>
    };

    1;

For different storage methods, you may want to set up your own get() in your
config package. You shouldn't need to 'use base N:O:S:Sa::Config' in such a
case.

    $ cat id
    #!/usr/bin/perl

    use warnings;
    use strict;
    our $nossaLibDir;

    BEGIN{
      use File::Basename qw/dirname/;
      use Cwd qw/realpath/;
      $nossaLibDir = realpath( dirname( __FILE__ ).'/../lib' );
      push( @INC, $nossaLibDir  )
        unless grep { $_ eq $nossaLibDir } @INC;
    }

    use MyApp::Nossa;

    MyApp::Nossa->id;

Same goes here for setup script except

    MyApp::Nossa->setup;

is the last line.

=head1 Downloads and more info

=head2 Web links

L<http://gitweb.vereshagin.org/nossa> - browseable repository with snapshots

L<http://code.google.com/p/nossa/> - home page with actual links, etc.

L<http://github.com/petr999/nossa> - GitHub page

L<http://bugs.vereshagin.org/buglist.cgi?product=Nossa> for bugs and reporting
of them

=head2 VCS downloads

Git users use this:

  git clone git://github.com/petr999/nossa

Subversion users use one of these:

  svn checkout http://nossa.googlecode.com/svn/trunk/ nossa-read-only
  svn checkout http://svn.github.com/petr999/nossa.git

=head1 AUTHOR, LICENSE

Peter Vereshagin <peter@vereshagin.org> ( L<http://vereshagin.org> ).

License: consider BSD is the closest to be of that domain.

=cut

1;
